{-
Copyright (c) 2007, Enrico Franchi
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
1) Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2) Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3) Neither my name nor the names of its contributors may be used to
endorse or promote products derived from this software without specific
prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-}


module Hydra
    where

data Hydra a b =
    Root {
      bodies :: [Hydra a b]
    } |
    Head {
      height :: a,
      label  :: b
    } |
    Body {
      height :: a,
      label  :: b,
      bodies :: [Hydra a b]
    }
    deriving (Eq)

instance (Show a, Show b) => Show (Hydra a b) where
    show Root{bodies=bs} = "R(<" ++ showChildren bs ++ ">)"
    show Head{label=l, height=h} = "H(" ++ show h ++ ","
                                        ++ show l ++ ")"
    show Body{bodies=bs, label=l, height=h} =
        "B(" ++ show h ++ "," ++
        show l ++ ",<" ++  showChildren bs ++ ">)"

prettyShow :: (Show a, Show b) => (Hydra a b) -> String
prettyShow hydra = prettyShow' 0 hydra
    where
      prettyShow' :: (Show a, Show b) => Int -> (Hydra a b) -> String
      prettyShow' n Head{} = fillWhite n ++ "()\n"
      prettyShow' n Body{bodies=bs} =
          fillWhite n ++ "(\n" ++
          concat (map (prettyShow' $! n+1) bs) ++
          fillWhite n ++ ")\n"
      prettyShow' n Root{bodies=bs} =
          fillWhite n ++ "(\n" ++
          concat (map (prettyShow' $! n+1) bs) ++
          fillWhite n ++ ")\n"
      fillWith  = (\f x y -> f y x) replicate
      fillWhite = fillWith ' '
      fillBlack = fillWith '#'

hydra_map :: (Hydra a b -> Hydra a b) -> Hydra a b -> Hydra a b
hydra_map f h@Head{} = f h
hydra_map f (Body h l bs) =
    let bs' = map (hydra_map f) bs in
    (Body h l bs')
hydra_map f (Root bs) =
    let bs' = map (hydra_map f) bs in
    (Root bs')

showChildren :: (Show a) => [a] -> [Char]
showChildren = concatMap (\h -> shows h "|")


makeHydra :: a -> b -> [Hydra a b] -> Hydra a b
makeHydra h l [] = Head h l
makeHydra h l bs = Body h l bs

isHead :: Hydra a b -> Bool
isHead Root{} = False
isHead Body{} = False
isHead Head{} = True

hydra_dup :: Hydra a b -> Hydra a b
hydra_dup (Head h l) = Head h l
hydra_dup (Body h l bs) = Body h l bs
hydra_dup (Root bs) = Root bs

cloneHydra :: Hydra a b -> Hydra a b
cloneHydra = hydra_map hydra_dup

chopHead :: Hydra a b -> (Bool, Hydra a b)
chopHead hydra@(Root bs) = (\(x, y, z) -> (x, y)) (chopHead' hydra)

chopHead' :: Hydra a b -> (Bool, Hydra a b, Maybe (Hydra a b))
chopHead' hydra =
    case hydra of
      Head{} -> error "chopHead': We should not get to chopping heads."
      Body h l bs ->
          let (done, bs') = removeHead bs in
          if done then
              let hydra' = makeHydra h l bs'
                  maybe_hydra = Just (cloneHydra hydra') in
              (done, hydra', maybe_hydra)
          else
              let (done', bs'') = chopHeads bs' in
              (done', makeHydra h l bs'', Nothing)
      Root bs ->
          let (done, bs') = removeHead bs in
          if done then
              (done, Root bs', Nothing)
          else
              let (done', bs'') = chopHeads bs' in
              (done', Root bs'', Nothing)

removeHead :: [Hydra a b] -> (Bool, [Hydra a b])
removeHead hs = removeHead' hs []
    where
      removeHead' :: [Hydra a b] -> [Hydra a b] -> (Bool, [Hydra a b])
      removeHead' [] processed = (False, reverse processed)
      removeHead' (h:hs) processed =
          if isHead h then
              (True, (reverse processed) ++ hs)
          else
              let processed' = h:processed in
              removeHead' hs processed'


chopHeads :: [Hydra a b] -> (Bool, [Hydra a b])
chopHeads bs = chopHeads' bs []
    where
      chopHeads' :: [Hydra a b] -> [Hydra a b] -> (Bool, [Hydra a b])
      chopHeads' []   processed = (False, reverse processed)
      chopHeads' (b:bs) processed =
          let (done, b', maybe_b') = chopHead' b in
          if done then
              let
                  l = maybe [b'] (\x -> [x, b'] ) maybe_b'
                  preparedList = (reverse (l ++ processed)) ++ bs
              in
                (done, preparedList)
          else
              chopHeads' bs (b':processed)

slayHydra :: Hydra a b -> Integer
slayHydra hydra =
    case hydra of
      Head{} -> error "slayHydra must be called only on roots"
      Body{} -> error "slayHydra must be called only on roots"
      (Root bs) -> slayHydra' 0 hydra
        where
          slayHydra' n hydra | seq n $ seq hydra $ False = undefined
          slayHydra' n hydra =
              let (done, hydra') = (chopHead hydra) in
              if done then (slayHydra' (n+1) hydra')
              else n

-- label :: Hydra a b -> Hydra Integer Integer

type    Index        =  Integer -- (Integer, Integer)
newtype Label a = Label (Index -> (Index, a))

instance Monad Label where
    return a = Label (\s -> (s, a))
    Label lb0 >>= f
          = Label $ \s0 ->
            let (s1, a1)  = lb0 s0
                Label lb1 = f a1
            in lb1 s1

mlabel hydra= let Label lt = label' hydra
              in snd (lt 1)

-- label' :: (Hydra a b)-> Label(Hydra a b)
label' (Head h l) =
    do l'  <- getLabel;
       return (Head h l')
label' (Body h l bs) =
    do l' <- getLabel;
       bs' <- mapM label' bs;
       return (Body h l' bs')
label' (Root bs) =
    do
      bs' <- mapM label' bs;
      return (Root bs')

-- getLabel :: Label Index
getLabel =  Label (\l -> (l+1, l) )
